home *** CD-ROM | disk | FTP | other *** search
/ Power Programmierung / Power-Programmierung (Tewi)(1994).iso / magazine / aijournl / 1987_03 / exprt1.mar < prev    next >
Text File  |  1987-02-19  |  7KB  |  196 lines
  1.  
  2.                  Expert's Toolbox -- March 1987
  3.                  "Heuristic State Space Search"
  4.                          by Marc Rettig
  5.  
  6.                         Listings 1 and 2
  7.  
  8.  
  9.  
  10. Listing 1
  11.  
  12. ; STATE-SPACE SEARCH PROCEDURE
  13. ;   These functions provide a general control structure for
  14. ; solving problems using heuristic search.  In order to apply
  15. ; this method to a particular problem, you must write the
  16. ; functions: initial-state, goal, successors, and print-solution.
  17. ;    See the "Expert's Toolbox" column in the March AI-Expert
  18. ; for a description of this algorithm and an example of its use.
  19. ;
  20. ; Algorithm given by Dr. Ralph Grishman, New York University,
  21. ; after Nils Nilsson, "Principles of Artificial Intelligence".
  22. ; Adapted for Xlisp by Marc Rettig (76703,1037).
  23.  
  24. (defun search ()
  25.     (prog (open closed n m successor-list same)
  26.  
  27.           ; Step 1. Put initial state on open.
  28.           (setq open (list (initial-state)))
  29.  
  30.           ; Step 2. If open is empty, exit with failure.
  31.      expand:
  32.           (cond ((null open) (print 'failure) (return nil)))
  33.  
  34.           ; Step 3. Remove state from open with minimum g + h and
  35.           ;    call it n.  (open is sorted by increasing g + h, so
  36.           ;    this is first element.)  Put n on closed.
  37.           ;    Exit with success if n is a goal node.
  38.           (setq n (car open))
  39.           (setq open (cdr open))
  40.           (setq closed (cons n closed))
  41.           (trace 'expanding n)
  42.           (cond ((goal n) (print-solution n) (return t)))
  43.  
  44.           ; For each m in successors(m):
  45.           (setq successor-list (successors n))
  46.      next-successor:
  47.           (cond ((null successor-list) (go expand:)))
  48.           (setq m (car successor-list))
  49.           (setq successor-list (cdr successor-list))
  50.           (trace 'successor m)
  51.           (cond ((setq same (find m open))
  52.                  ; if m is on open, reset g if new value is smaller
  53.                  (cond
  54.                   ((< (get m 'g) (get same 'g))
  55.                    (setq open (add m (remove same open))))))
  56.                 ((setq same (find m closed))
  57.                  ; If m is on closed and new value of g is smaller,
  58.                  ; remove state from closed and add it to open with new g.
  59.                  (cond
  60.                   ((< (get m 'g) (get same 'g))
  61.                    (setq closed (remove same closed))
  62.                    (setq open (add m open)))))
  63.                 (t 
  64.                   ; else add m to open
  65.                   (setq open (add m open))))
  66.           (go next-successor:)))
  67.  
  68. (defun add (state s-list)
  69.     ; Inserts state into s-list so that list remains ordered
  70.     ; by increasing g + h.
  71.     (cond ((null s-list) (list state))
  72.           ((> (+ (get (car s-list) 'g) (get (car s-list) 'h))
  73.               (+ (get state 'g) (get state 'h)))
  74.            (cons state s-list))
  75.           (t (cons (car s-list) (add state (cdr s-list))))))
  76.  
  77. (defun find (state s-list)
  78.     ; returns first entry on s-list whose position is same
  79.     ; as that of state.
  80.     (cond ((null s-list) nil)
  81.           ((equal (get state 'position)
  82.                   (get (car s-list) 'position))
  83.            (car s-list))
  84.           (t (find state (cdr s-list)))))
  85.  
  86.  
  87.  
  88. Listing 2
  89.  
  90. ;  M I S S I O N A R I E S   A N D   C A N N I B A L S
  91. ;
  92. ;  The following routines, when used in conjunction with the state-space
  93. ;  search procedure, solve the missionaries and cannibals problem.  Three
  94. ;  missionaries and 3 cannibals are located on the right bank of a river,
  95. ;  along with a two-man rowboat.  We must find a way of moving all the
  96. ;  missionaries and cannibals to the left bank.  However, if at any time
  97. ;  there are more cannibals than missionaries on a bank, the cannibals will
  98. ;  exhibit a consuming interest in the misssionaries;  this must be avoided.
  99. ;
  100. ;  Each state is represented by an atom with the following properties:
  101. ;      position -- a list of three elements,
  102. ;        the number of missionaries on the right bank
  103. ;        the number of cannibals on the right bank
  104. ;        the position of the boat (left or right)
  105. ;    g       -- the estimated g for that state
  106. ;    h       -- the estimated h (value of function heuristic) 
  107. ;    parent  -- the preceding state on the path from the initial state
  108. ;                (the preceding state which gives rise to the least g,
  109. ;                        if there are several)
  110.  
  111. (defun initial-state ()
  112.   ;  return the initial state
  113.   (build-state 3 3 'right 0 nil))
  114.  
  115. (defun successors (state)
  116.   ;  returns the successors of state
  117.   ;  note that procedure try uses state and new-g, and modifies suc
  118.   (prog (m c boat new-g suc)  
  119.     ;  extract parameters of current position and put in m, c, and boat
  120.     (setq m (car (get state 'position)))
  121.     (setq c (cadr (get state 'position)))
  122.     (setq boat (caddr (get state 'position)))
  123.     ;  g of new state = g of old state + 1 (all crossings are unit cost)
  124.     (setq new-g (+ 1 (get state 'g)))
  125.     (cond ((equal boat 'right)
  126.            (try (- m 2) c 'left new-g)
  127.            (try (- m 1) c 'left new-g)
  128.            (try (- m 1) (- c 1) 'left new-g)
  129.            (try m (- c 1) 'left new-g)
  130.            (try m (- c 2) 'left new-g))
  131.           (t  ; boat is on left
  132.            (try (+ m 2) c 'right)
  133.            (try (+ m 1) c 'right)
  134.            (try (+ m 1) (+ c 1) 'right)
  135.            (try m (+ c 1) 'right)
  136.            (try m (+ c 2) 'right)))
  137.     (return suc)))
  138.  
  139. (defun try (new-m new-c new-boat new-g)
  140.   ;  if position(new-m,new-c,new-boat) is valid, add new state to suc
  141.   (cond ((valid new-m new-c)
  142.      (setq suc (cons (build-state new-m new-c new-boat new-g state)
  143.              suc)))))
  144.  
  145. (defun valid (miss cann)
  146.   ;  returns true if having 'miss' missionaries and 'cann' cannibals
  147.   ;  on the right bank is a valid state
  148.   (and (>= miss 0)
  149.        (>= cann 0)
  150.        (< miss 4)
  151.        (< cann 4)
  152.        (or (zerop miss) (>= miss cann))
  153.        (or (zerop (- 3 miss)) (>= (- 3 miss) (- 3 cann)))))
  154.  
  155. (defun build-state (miss cann boat g parent)
  156.   ;  creates a new state with parameters as specified by argument list
  157.   (prog (newstate)
  158.     (setq newstate (gensym))
  159.     (putprop newstate (list miss cann boat) 'position)
  160.     (putprop newstate g 'g)
  161.     (putprop newstate (heuristic miss cann boat) 'h)
  162.     (putprop newstate parent 'parent)
  163.     (return newstate)))
  164.  
  165. (defun heuristic (miss cann boat)
  166.   ;  our heuristic (h) function
  167.   (cond ((equal boat 'left)
  168.      (* 2 (+ miss cann)))
  169.     (t  ;  boat is on right
  170.      (* 2 (max 0 (+ miss cann -2))))))
  171.  
  172. (defun goal (state)
  173.   ;  returns true if state is a goal state (no missionaries or cannibals on right)
  174.   (and (zerop (car (get state 'position)))
  175.        (zerop (cadr (get state 'position)))))
  176.  
  177. (defun print-solution (state)
  178.   ;  invoked by search algorithm with goal state,
  179.   ;  prints sequence of states from initial state to goal.
  180.   (cond ((null state)
  181.       (print 'solution:))
  182.      (t
  183.       (print-solution (get state 'parent))
  184.       (print (get state 'position))
  185.      ))
  186. )
  187.  
  188. (defun trace (comment state)
  189.   ; if trace-switch is true, print out comment and position
  190.   ; associated with state
  191.   (cond 
  192.     (trace-switch
  193.       (print `(,comment state ,state with position ,(get state 'position)
  194.                h(x) =  ,(get state 'h))))))
  195.  
  196.